home *** CD-ROM | disk | FTP | other *** search
/ Whiteline: Alpha / Whiteline Alpha.iso / progtool / modula2 / excard / exfunc.mod < prev    next >
Encoding:
Modula Implementation  |  1994-09-22  |  2.6 KB  |  116 lines
  1. IMPLEMENTATION MODULE ExFunc;
  2.  
  3. (*            Implementationsmodul ExFunc Version 1.0                 *
  4.  *          Copyright: K. Hartlage, Pr.Stroehen 194, 4993 Rahden      *
  5.  * Berechnung (Ex-)tra langer (Card-)inalzahlen;                      *
  6.  * Verbesserungen, Berichtigungen und eigene Anwendungen bitte an die *
  7.  * obige Adresse senden                                               *)
  8.  
  9. FROM SYSTEM IMPORT ADR,CODE,ADDRESS;
  10.  
  11. FROM Excard IMPORT 
  12.   ExCard;  
  13.  
  14. FROM Excard IMPORT 
  15.   Def,CardToExCard,ExEqual,ExLess,ExOdd,ExInc,ExAdd,ExSub,ExMul,
  16.   ExShl,ExShr,ExDiv,ExMod,ExRead,ExWrite ;
  17.  
  18. PROCEDURE ExFak(VAR facc : ExCard; f : CARDINAL);
  19. (* facc := f! *)
  20. VAR  i:CARDINAL;
  21.      lx,n:ExCard;
  22. BEGIN
  23.   CardToExCard(facc,1);
  24.   CardToExCard(lx,1);
  25.   CardToExCard(n,f);
  26.   WHILE ExLess(lx,n) DO
  27.     ExInc(lx);
  28.     ExMul(facc,lx,facc);
  29.   END
  30. END ExFak;
  31.  
  32. PROCEDURE MueberN(VAR result : ExCard; m,n : CARDINAL);
  33. (* result:=m! / (n! * (m-n)! ) *)
  34. VAR t0,f0,lx,stop      : ExCard;
  35.     c1      : CARDINAL;
  36. BEGIN
  37.   IF (m<n) & (0<=m) THEN 
  38.     CardToExCard(result,0);
  39.   ELSIF (m-n=0) OR (n=0) THEN
  40.     CardToExCard(result,1);
  41.   ELSIF n<=m-n THEN
  42.     CardToExCard(f0,1);
  43.     CardToExCard(lx,m-n);
  44.     CardToExCard(stop,m);
  45.     WHILE ExLess(lx,stop) DO
  46.       ExInc(lx);
  47.       ExMul(f0,lx,f0);
  48.     END;
  49.     ExFak(t0,n);
  50.     ExDiv(result,f0,t0);
  51.   ELSE
  52.     CardToExCard(f0,1);
  53.     CardToExCard(lx,n);
  54.     CardToExCard(stop,m);
  55.     WHILE ExLess(lx,stop) DO
  56.       ExInc(lx);
  57.       ExMul(f0,lx,f0);
  58.     END;
  59.     ExFak(t0,m-n);
  60.     ExDiv(result,f0,t0);
  61.   END
  62. END MueberN;
  63.  
  64. PROCEDURE ExggT(VAR ggt,n0,m0 : ExCard);
  65. (* bestimmt groessten gemeinsamen Teiler *)
  66. VAR rest,temp0,temp1,null : ExCard;
  67. BEGIN 
  68.   CardToExCard(null,0);
  69.   IF ExLess(n0,m0) THEN 
  70.     Def(temp0,ADR(m0));
  71.     Def(temp1,ADR(n0))
  72.   ELSE 
  73.     Def(temp0,ADR(n0));
  74.     Def(temp1,ADR(m0))
  75.   END;
  76.   CardToExCard(rest,1);
  77.   WHILE NOT ExEqual(rest,null) DO
  78.     ExMod(rest,temp0,temp1);
  79.     Def(temp0,ADR(temp1));
  80.     Def(temp1,ADR(rest));
  81.   END;
  82.   Def(ggt,ADR(temp0));
  83. END ExggT;
  84.  
  85. PROCEDURE ExkgV(VAR kgv,n0,m0 : ExCard);
  86. (* bestimmt kleinstes gemeinsames Vielfaches *)
  87. VAR ggt,prod : ExCard;
  88.  
  89. BEGIN 
  90.   ExMul(prod,n0,m0);
  91.   ExggT(ggt,n0,m0);
  92.   ExDiv(kgv,prod,ggt);
  93. END ExkgV;
  94.  
  95. PROCEDURE ExSum(VAR sum,n : ExCard);
  96. (* sum := 1+2+3+...+n *)
  97. VAR  dummy : BOOLEAN;
  98.      t0,t1:ExCard;
  99. BEGIN
  100.   Def(t0,ADR(n));
  101.   IF ExOdd(t0) THEN
  102.     ExInc(t0);
  103.     dummy:=ExShr(t0);
  104.     Def(t1,ADR(n));
  105.     ExMul(sum,t0,t1);
  106.   ELSE
  107.     dummy:=ExShr(t0);
  108.     Def(t1,ADR(n));
  109.     ExInc(t1);
  110.     ExMul(sum,t0,t1);
  111.   END
  112. END ExSum;
  113.  
  114. END ExFunc.
  115.  
  116.